(defun ecrire-mem (vm adr val)
  (setf (aref (get vm 'mem) adr) val))

(defun lire-mem (vm adr)
  (aref (get vm 'mem) adr))

(defun lire-reg (vm reg)
  (get vm reg))

(defun ecrire-reg (vm reg val)
  (setf (get vm reg) val))

(defun lire-emplacement (vm adr)
  (if (atom adr)
      (if (numberp adr)
	  (lire-mem vm adr)
	(lire-reg vm adr))
    (if (numberp (car adr))
	(if (atom (cadr adr))
	    (if (numberp (cadr adr))
		(lire-mem vm (+ (car adr) (cadr adr)))
	      (lire-mem vm (+ (car adr) (lire-reg vm (cadr adr)))))
	  (if (eql (caadr adr) '*)
	      (if (numberp (cadadr adr))
		  (lire-mem vm (+ (car adr) (lire-mem vm (cadadr adr))))
		(lire-mem vm (+ (car adr) (lire-mem vm (lire-reg vm (cadadr adr))))))
	    (error "~s : ce mode d'adressage n'est pas connu" adr)))
      (if (eql (car adr) '*)
	  (if (numberp (cadr adr))
	      (lire-mem vm (lire-mem vm (cadr adr)))
	    (lire-mem vm (lire-mem vm (lire-reg vm (cadr adr)))))
	(error "~s : ce mode d'adressage n'est pas connu" adr)))))

(defun ecrire-emplacement (vm adr val)
  (if (atom adr)
      (if (numberp adr)
	  (ecrire-mem vm adr val)
	(ecrire-reg vm adr val))
    (if (numberp (car adr))
	(if (atom (cadr adr))
	    (if (numberp (cadr adr))
		(ecrire-mem vm (+ (car adr) (cadr adr)) val)
	      (ecrire-mem vm (+ (car adr) (lire-reg vm (cadr adr))) val))
	  (if (eql (caadr adr) '*)
	      (if (numberp (cadadr adr))
		  (ecrire-mem vm (+ (car adr) (lire-mem vm (cadadr adr))) val)
		(ecrire-mem vm (+ (car adr) (lire-mem vm (lire-reg vm (cadadr adr)))) val))
	    (error "~s : ce mode d'adressage n'est pas connu" adr)))
      (if (eql (car adr) '*)
	  (if (numberp (cadr adr))
	      (ecrire-mem vm (lire-mem vm (cadr adr)) val)
	    (ecrire-mem vm (lire-mem vm (lire-reg vm (cadr adr))) val))
	(error "~s : ce mode d'adressage n'est pas connu" adr)))))



(defun vm-move (vm r0 r1)
  (if (numberp r1)
      (ecrire-reg vm r0 r1)
    (if (not (symbolp r1))
	(ecrire-reg vm r0 r1)
      (ecrire-reg vm r0 (lire-reg vm r1)))))

(defun vm-load (vm r0 r1)
  (ecrire-reg vm r0 (lire-emplacement vm r1)))

(defun vm-store (vm r0 r1)
  (ecrire-emplacement vm r0 (lire-reg vm r1)))


(defun vm-add (vm r0 r1)
  (ecrire-reg vm r0 (+ (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-sub (vm r0 r1)
  (ecrire-reg vm r0 (- (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-mult (vm r0 r1)
  (ecrire-reg vm r0 (* (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-div (vm r0 r1)
  (ecrire-reg vm r0 (/ (lire-reg vm r0) (lire-reg vm r1))))

(defun vm-incr (vm reg)
  (ecrire-reg vm reg (+ (lire-reg vm reg) 1)))

(defun vm-decr (vm reg)
  (ecrire-reg vm reg (- (lire-reg vm reg) 1)))

(defun vm-push (vm reg)
  (ecrire-reg vm 'SP (+ (lire-reg vm 'SP) 1))
  (vm-store vm (lire-reg vm 'SP) reg))

(defun vm-pop (vm reg)
  (vm-load vm reg (lire-reg vm 'SP))
  (ecrire-reg vm 'SP (- (lire-reg vm 'SP) 1)))

(defun vm-cmp (vm r1 r2)
  (ecrire-reg vm 'DE 0)
  (ecrire-reg vm 'DG 0)
  (ecrire-reg vm 'DP 0)
  (if (< r1 r2)
      (ecrire-reg vm 'DP 1)
    (if (> r1 r2)
	(ecrire-reg 'DG 1)
      (ecrire-reg 'DE 1))))



(defun vm-jmp (vm etiq)
					; si c'est une etiquette
  (if (not (numberp etiq))
      (if (fboundp etiq)
	  (funcall etiq (lire-mem vm (+ (lire-reg vm 'FP) xx) (+ (lire-reg vm 'FP) xx)))
	(error "~s n'est pas une fonction définie dans clisp, ou alors vous avez oublié de la meta definie" etiq))
					; si c'est une adresse valide
    (if (adr-valide-p vm etiq)
	(ecrire-reg vm 'CO (+ etiq 1))
      (error "on ne peut faire de JMP vers ~s. Address out of bounds" etiq))))

					; Appel de sous routine aka appel de fonction
(defun vm-jsr (vm adr)
  (print "je suis dans le jsr")
  (if (numberp adr)
      (progn (vm-push vm (- (lire-reg vm 'CO) 1))
	     (vm-jmp vm adr))
    (if (fboundp adr)
	(progn (setq lparams ())
	       (loop for indice from (lire-mem vm (lire-reg vm 'FP)) downto 1
		     append (list (lire-mem vm (- (lire-reg vm 'FP) indice))) into lparams_loop
		     finally (setq lparams lparams_loop))
	       (print "une fonction externe est appellée avec les parametres")
	       (print lparams)
	       (if lparams
		   (apply adr lparams)
		 (funcall adr )))
      (error "~s n'est pas une fonction définie dans clisp, ou alors vous avez oublié de la meta definir" adr))))

(defun vm-rtn (vm)
  (vm-pop vm 'R2)
  (vm-jmp vm (lire-reg vm 'R2)))

(defun vm-jeq (vm adr)
  (if (and (eq (lire-reg vm 'DE) 1)
	   (eq (lire-reg vm 'DG) 0)
	   (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
    ))
(defun vm-jpp (vm adr)
  (if (and (eq (lire-reg vm 'DE) 0)
	   (eq (lire-reg vm 'DG) 0)
	   (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
    ))
(defun vm-jpg (vm adr)
  (if (and (eq (lire-reg vm 'DE) 0)
	   (eq (lire-reg vm 'DG) 1)
	   (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
    ))
(defun vm-jne (vm adr)
  (if (or (eq (lire-reg vm 'DE) 0)
	  (eq (lire-reg vm 'DG) 1)
	  (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
    ))
(defun vm-jpe (vm adr)
  (if (or (eq (lire-reg vm 'DE) 1)
	  (eq (lire-reg vm 'DG) 0)
	  (eq (lire-reg vm 'DP) 1))
      (vm-jmp vm adr)
    ))
(defun vm-jge (vm adr)
  (if (or (eq (lire-reg vm 'DE) 1)
	  (eq (lire-reg vm 'DG) 1)
	  (eq (lire-reg vm 'DP) 0))
      (vm-jmp vm adr)
    ))

(defun vm-halt (vm)
  (ecrire-reg vm 'RUN 0))

(defun vm-nop (vm)
  t)



(defun make-vm (nom taillemem env)

  (ecrire-reg nom 'mem  (make-array '(10000) ))

  (ecrire-reg nom 'r0 1)
  (ecrire-reg nom 'r1 2)
  (ecrire-reg nom 'r2 3)

  (ecrire-reg nom 'DE 0)
  (ecrire-reg nom 'DG 0)
  (ecrire-reg nom 'DP 0)

  (ecrire-reg nom 'SP 0)
  (ecrire-reg nom 'BP 1)
  (ecrire-reg nom 'FP 1)

  (ecrire-reg nom 'RUN 0)

  (ecrire-reg nom 'CO 500)

					; adresses de debut et fin de code chargé dans la vm
  (ecrire-reg nom 'debcode (- taillemem 1))
					; premiere case libre pour du code
  (ecrire-reg nom 'fincode (- taillemem 1))

  )

(defun command (vm com)
  (eql (car (lire-mem vm (lire-reg vm 'CO))) com))


(defun run-vm (vm start)

  (ecrire-reg vm 'RUN 1)
  (ecrire-reg vm 'CO start)

  (loop while (eql (lire-reg vm 'RUN) 1)
	do (if (command vm 'ADD)
	       (vm-add vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
	     (if (command vm 'HALT)
		 (vm-halt vm)
	       (if (command vm 'JMP)
		   (vm-jmp vm (cadr (lire-mem vm (lire-reg vm 'CO))))
		 (if (command vm 'JSR)
		     (vm-jsr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
		   (if (command vm 'SUB)
		       (vm-sub vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
		     (if (command vm 'MULT)
			 (vm-mult vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
		       (if (command vm 'DIV)
			   (vm-div vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			 (if (command vm 'LOAD)
			     (vm-load vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			   (if (command vm 'STORE)
			       (vm-store vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			     (if (command vm 'MOVE)
				 (vm-move vm (cadr (lire-mem vm (lire-reg vm 'CO))) (caddr (lire-mem vm (lire-reg vm 'CO))))
			       (if (command vm 'INCR)
				   (vm-incr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				 (if (command vm 'DECR)
				     (vm-decr vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				   (if (command vm 'PUSH)
				       (vm-push vm (cadr (lire-mem vm (lire-reg vm 'CO))))
				     (if (command vm 'POP)
					 (vm-pop vm (cadr (lire-mem vm (lire-reg vm 'CO))))))))))))))))))

					; on decremente le CO car le code est descendant
	do (vm-decr vm 'CO)))

					; ne fait pas la resolution d'etiquettes
(defun vm-loader (vm adr file)
  (setf (get 'mavar 'adr) adr)
  (with-open-file (stream file
			  :direction :input
			  :if-does-not-exist :error)
		  (loop for bloc = (read stream nil 'EOF)
			until (eql bloc 'EOF)
			do (ecrire-mem vm (get 'mavar 'adr) bloc)
			do (setf (get 'mavar 'adr) (- (get 'mavar 'adr) 1))
			do (print '--)
			)))

(defun vm-loader2 (vm adr file)
  (setf (get 'mavar 'adr) adr)
  ;(with-open-file (stream file
	;		  :direction :input
	;		  :if-does-not-exist :error)
		  (loop for bloc in file
			do (ecrire-mem vm (get 'mavar 'adr) bloc)
			do (setf (get 'mavar 'adr) (- (get 'mavar 'adr) 1))
			))

(defun jump-p (instr)
  (or (eql instr 'JMP)
      (eql instr 'JSR)
      (eql instr 'JEQ)
      (eql instr 'JNE)
      (eql instr 'JPG)
      (eql instr 'JPP)
      (eql instr 'JPE)
      (eql instr 'JGE)))

					; ecrit le contenu de la memoire de deb à fin
(defun dump-mem (vm deb fin)
					; variable de parcours de la memoire
  (setf (get 'adr-dump 'adr) deb)
  (loop for case-mem = (lire-mem vm (get 'adr-dump 'adr))
	until (eql (get 'adr-dump 'adr) (- fin 1))
	do (print (get 'adr-dump 'adr))
	do (print case-mem)
	do (setf (get 'adr-dump 'adr) (- (get 'adr-dump 'adr) 1))))



(make-vm 'vvvm 1000 ())
;(vm-loader 'vvvm 1000 "test2.lisp")
;(print (lire-reg 'vvvm 'r0))
(vm-loader2 'vvvm 1000 (lisp-to-vm '(fibo 12) nil))
(vm-loader2 'vvvm 1000 '((HALT)))
(run-vm 'vvvm 1000)
(print (lire-reg 'vvvm 'r0))
;(print "j'ai lu les registres")

; Le code est DESCENDANT : on decremente le CO
;
; La pile est MONTANTE : on incremente le SP (pour push)
;
; le SP pointe sur le dernier emplacement utilisé de la pile
; on doit donc incrementer le SP avant de push qqch sur la pile
;
; Le FP pointe initialement sur la case mem 1,
